(require* sketch/parse/rule/util)

(defrule trianglearrowhead-oah-line
    "triangle-arrow-head = open-arrow-head, line"
    ?fo <- (shape (name "OpenArrowHead") (obj ?oah))
    ?fl <- (shape (name "Line") (obj ?l))
    (test (call ShapePredicate joinsLinePoint ?l (?oah getHeadSideP1)))
    (test (call ShapePredicate joinsLinePoint ?l (?oah getHeadSideP2)))
    =>
    (printout "recognize triangle-arrow-head = open-arrow-head, line")
    (bind ?sh (new TriangleArrowHead))
    (?sh setHead (?oah getHead))
    (?sh setTail (?oah getTail))
    (?sh setAngle (?oah getAngle))
    (?sh setLength (?oah getLength))
    (retract ?fo)
    (retract ?fl)
    (assert (shape
            (name "TriangleArrowHead")
            (obj ?sh)
            (children ?oah ?l)))
    (recognize ?sh (list-children (create$ ?oah ?l))))

(defrule trianglearrowhead-triangle-line
	"triangle-arrow-head = triangle, line"
    ?ft <- (shape (name "Triangle") (obj ?tri))
    ?fl <- (shape (name "Line") (obj ?l))
    (test (call ShapePredicate attachedByVertexTriangleLine ?tri ?l))
    (test (call ShapePredicate equalLengthLineLine
            (?tri getSideL1Of (?tri getCommonPointTo ?l))
            (?tri getSideL2Of (?tri getCommonPointTo ?l))))
    (test (call ShapePredicate orthogonalLineLine
			(?tri getFaceOf (?tri getCommonPointTo ?l)) ?l))
    (test (call ShapePredicate acrossLineLine
			(?tri getFaceOf (?tri getCommonPointTo ?l)) ?l))
	=>
    (printout "recognize triangle-arrow-head = triangle, line")
    (bind ?sh (new TriangleArrowHead))
    (?sh setHead (?tri getCommonPointTo ?l))
    (?sh setTail (?l getEndPointTo (?sh getHead)))
    (?sh setAngle (* .5 (?tri getAngleOf (?sh getHead))))
    (?sh setLength ((?tri getSideL1Of (?sh getHead)) length))

    (bind ?shl (new Line))
    (?shl setP1 (?l getCenter))
    (?shl setP2 (?sh getTail))
    (?sh setTail (?l getCenter))

    (retract ?ft)
    (retract ?fl)

    (assert (shape
            (name "TriangleArrowHead")
            (obj ?sh)
            (children ?tri ?l)))
    (recognize ?sh (list-children (create$ ?tri ?l)))
    (assert (shape
            (name "Line")
            (obj ?shl)
            (children ?l)))
    (recognize ?shl (list-children (create$ ?l))))

(defrule diamondarrowhead-oah-line
    "diamond-arrow-head = open-arrow-head, line"
	?fo <- (shape (name "OpenArrowHead") (obj ?oah))
    ?f1 <- (shape (name "Line") (obj ?l1))
    ?f2 <- (shape (name "Line") (obj ?l2))
    (test (call ShapePredicate joinsLinePoint ?l1 (?oah getHeadSideP1)))
    (test (call ShapePredicate joinsLinePoint ?l2 (?oah getHeadSideP2)))
	(test (call ShapePredicate joinsLineLine ?l1 ?l2))
    (test (call ShapePredicate containsLinePoint
            (?oah getShaft)
            (?l1 getCommonPointTo ?l2)))
	(test (call ShapePredicate equalLength (?l1 length) (?oah getLength)))
    (test (call ShapePredicate equalLength (?l2 length) (?oah getLength)))
    =>
    (printout "recognize diamond-arrow-head = open-arrow-head, line")
    (bind ?sh (new DiamondArrowHead))
    (?sh setHead (?oah getHead))
    (?sh setTail (?oah getTail))
    (?sh setAngle (?oah getAngle))
    (?sh setLength (?oah getLength))
    (retract ?fo)
    (retract ?f1)
    (retract ?f2)
    (assert (shape
            (name "DiamondArrowHead")
            (obj ?sh)
            (children ?oah ?l1 ?l2)))
    (recognize ?sh (list-children (create$ ?oah ?l1 ?l2))))
